home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / MacMarlais 0.5.9d46 / external primitive / Source / external_primitive.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-02-28  |  3.2 KB  |  153 lines  |  [TEXT/KAHL]
  1. /*
  2.     external_primitive.c
  3.     
  4.     an example external primitive.
  5.     
  6.     by Patrick C. Beard.
  7.     
  8.     <Revision History>
  9.     01/01/95  pcb  Created.
  10.     02/28/95  pcb  Compiling for PPC.
  11.  */
  12.  
  13. #ifndef __TYPES__
  14. #include <Types.h>
  15. #endif
  16. #ifndef __MEMORY__
  17. #include <Memory.h>
  18. #endif
  19.  
  20. #include "external_primitive.h"
  21.  
  22. #if !defined(powerc)
  23. #ifdef THINK_C
  24. #include <SetUpA4.h>
  25. #define InitGlobals()    RememberA0()
  26. #define OpenGlobals()    SetUpA4()
  27. #define CloseGlobals()    RestoreA4()
  28. #endif /* THINK_C */
  29. #else
  30. #define InitGlobals()
  31. #define OpenGlobals()
  32. #define CloseGlobals()
  33. #endif
  34.  
  35. #if !defined(InitGlobals)
  36. #error "Unsupported configuration."
  37. #endif
  38.  
  39. ExternalPrimitiveCallbacks* callbacks;
  40. ExternalPrimitiveObjects* objects;
  41.  
  42. ExternalPrimitiveCallbacks* GetCallbacks()
  43. {
  44.     ExternalPrimitiveCallbacks* cb;
  45.     OpenGlobals();
  46.     cb = callbacks;
  47.     CloseGlobals();
  48.     return cb;
  49. }
  50.  
  51. ExternalPrimitiveObjects* GetObjects()
  52. {
  53.     ExternalPrimitiveObjects* ob;
  54.     OpenGlobals();
  55.     ob = objects;
  56.     CloseGlobals();
  57.     return ob;
  58. }
  59.  
  60. void GetSupport(ExternalPrimitiveCallbacks** cb, ExternalPrimitiveObjects** ob)
  61. {
  62.     OpenGlobals();
  63.     *cb = callbacks;
  64.     *ob = objects;
  65.     CloseGlobals();
  66. }
  67.  
  68. static Object debug_string(Object messageObj)
  69. {
  70.     ExternalPrimitiveCallbacks* callbacks;
  71.     Str255 message;
  72.     
  73.     message[0] = BYTESTRSIZE(messageObj);
  74.     BlockMoveData(BYTESTRVAL(messageObj), message + 1, message[0]);
  75.  
  76.     DebugStr(message);
  77.     
  78.     // getting an object's value the hard way.
  79.     callbacks = GetCallbacks();
  80.     return callbacks->symbol_value(callbacks->make_symbol("%unspecified"));
  81. }
  82.  
  83. static Object new_ptr(Object sizeObj)
  84. {
  85.     ExternalPrimitiveCallbacks* callbacks;
  86.     Object plus_symbol;
  87.     Object one;
  88.     Object expr_list;
  89.     Ptr ptr;
  90.     
  91.     callbacks = GetCallbacks();
  92.      
  93.     // always add an extra byte to show how to use eval and apply.
  94.     plus_symbol = callbacks->make_symbol("+");                            // create a "+" symbol.
  95.     one = MAKE_INT(1);                                                    // create a 1 object.
  96.     expr_list = callbacks->listem(plus_symbol, sizeObj, one, NULL);        // (+ sizeObj 1)
  97.     sizeObj = callbacks->eval(expr_list);                                // evaluate the list.
  98.     
  99.     ptr = NewPtr(INTVAL(sizeObj));
  100.     if (!ptr) {
  101.         callbacks->error("%new-ptr: couldn't allocate requested size", sizeObj, NULL);
  102.     }
  103.     
  104.     return callbacks->make_foreign_ptr(ptr);
  105. }
  106.  
  107. static Object dispose_ptr(Object ptrObj)
  108. {
  109.     ExternalPrimitiveCallbacks* callbacks;
  110.     ExternalPrimitiveObjects* objects;
  111.     
  112.     GetSupport(&callbacks, &objects);
  113.     
  114.     if (!FOREIGNP(ptrObj)) {
  115.         callbacks->error("%dispose-ptr: argument not a foreign pointer", ptrObj, NULL);
  116.     }
  117.     
  118.     DisposePtr((Ptr)FOREIGNPTR(ptrObj));
  119.     FOREIGNPTR(ptrObj) = 0;
  120.  
  121.     return objects->unspecified_object;
  122. }
  123.  
  124. static void set_primitive(struct primitive* prim, char *name,
  125.                             enum primtype prim_type, Object (*fun) ())
  126. {
  127.     prim->name = name;
  128.     prim->prim_type = prim_type;
  129.     prim->fun = fun;
  130. }
  131.  
  132. void main(ExternalPrimitiveSupport* support)
  133. {
  134.     struct primitive external_prims[3];
  135.  
  136.     InitGlobals();
  137.     OpenGlobals();
  138.     
  139.     // initialize some globals.
  140.     callbacks = support->callbacks;
  141.     objects = support->objects;
  142.     
  143.     // initialize the primitives.
  144.     set_primitive(&external_prims[0], "%debug-string", prim_1, &debug_string);
  145.     set_primitive(&external_prims[1], "%new-ptr", prim_1, &new_ptr);
  146.     set_primitive(&external_prims[2], "%dispose-ptr", prim_1, &dispose_ptr);
  147.  
  148.     // install the primitives.
  149.     callbacks->init_prims(3, external_prims);
  150.  
  151.     CloseGlobals();
  152. }
  153.